Download and load raster
The raster is freely available from the web
# Download globCover dataset
# download.file('http://due.esrin.esa.int/files/Globcover2009_V2.3_Global_.zip',destfile = "Globcover2009_V2.3_Global_.zip")
# unzip('Globcover2009_V2.3_Global_.zip',exdir = 'GlobCover')
# Load raster
glob = raster("GLOBCOVER_L4_200901_200912_V2.3.tif")
We also need to map the Globcover labels to a continous number, as indicated by the legend found here. We set water bodies to NA. Later on, we set the roughness ot water bodies to 100 to indicate that the squirrel cannot swim over them.
# map labels to roughness values
globCover = c(11,14,20,30,40,50,60,70,90,100,
110,120,130,140,150,160,170,180,190,200,210,220,230)
roughness = c(0.10, 0.10, 0.30, 0.30, 1.50, 1.50, 1.50, 1.50, 1.50, 1.50,
1.50, 0.50, 0.10, 0.03, 0.05, 0.50, 0.60, 0.20, 1.00, NA, NA, NA, NA)
Map of Spain
We chop a small section of the world map around the Iberian peninsula. The code is made to work only for squared rasters.
The start and end points of the path are set to be the northernmost point (Estaca do bares) and the sourthernmost one (Tarifa).
# Chop a small section
lat = 40
lon = -5.1
n=4.5 # width of the box
cropbox2 <-c(lon-n,lon+n,lat-n,lat+n) # crop a square box
spain_img = crop(glob,cropbox2)
# re-classify the raster values to numeric
small_img_plot = reclassify(spain_img,cbind(globCover,roughness))
# Let's tranform NA values to "-100" roughness so that we squirrel cannot swim. This one is only used for calculations.
small_img = reclassify(small_img_plot,c(NA,-100,-100))
# Save the rasters for later use in the dashboard
raster::writeRaster(spain_img, "Files/GlobCover_Spain.tif",overwrite=TRUE)
# Plot
# plot(spain_img) # Original globcover labels
plot(small_img_plot) # transformed labels, with NA
# plot(small_img) # we use this one for the analysis with NA=-100
# Start and end points
start_point = c(43.780824, -7.681479) # Estaca do bares
end_point = c(36.003797, -5.609124)# Tarifa
# Plot start and end points
points(x=start_point[2],y=start_point[1],pch=19)
points(x=end_point[2],y=end_point[1],pch=19)

Dimensions of the raster:
# translate raster to matrix
mat = raster::as.matrix(small_img)
# create 0-1 edge matrix
N = dim(mat)[1] * dim(mat)[2] # Number of vertices
Ni= dim(mat)[1] # number of rows
Nj= dim(mat)[2] # number of columns
N
[1] 10497600
Next we create the graph as a matrix. The matrix is equal to a 0 if two pixels are not linked, and equal to the roughness of theincoming pixel if they are. Two pixels are linked if they are adjacent to each other. This huge matrix of dimension 10497600 by 10497600 is really sparse and unless optimized takes too long to be created. It is build inside the function build_matrix_graph() and it took few tries to make it run at reasonable speeds.
The values of the raster are slighly modified to be used in a standard shortest-path algorithm: 0.0000001 weight on an edge means “forest”, while 1.5 means “bare land” and 100 means “water bodies”.
# Call our homemade function
val_raster = 1.5-values(small_img)+0.0000001
t = Sys.time()
mat_path = build_matrix_graph(Ni,Nj,val_raster = val_raster)
Sys.time() - t
Time difference of 32.85089 secs
mat_path[1:10,1:10]
10 x 10 sparse Matrix of class "dgCMatrix"
[1,] . 101.5 . . . . . . . .
[2,] 101.5 . 101.5 . . . . . . .
[3,] . 101.5 . 101.5 . . . . . .
[4,] . . 101.5 . 101.5 . . . . .
[5,] . . . 101.5 . 101.5 . . . .
[6,] . . . . 101.5 . 101.5 . . .
[7,] . . . . . 101.5 . 101.5 . .
[8,] . . . . . . 101.5 . 101.5 .
[9,] . . . . . . . 101.5 . 101.5
[10,] . . . . . . . . 101.5 .
The shortest path is claulcated using the igraph library. It works surprisingly fast.
# Build igraph
g <- graph.adjacency(mat_path, mode="directed",weighted = T)
## Calculate shortest path between two poitns
# Find index of the start and end point
img_points = rasterToPoints(small_img)
idx_start = which.min( abs( img_points[,1] - start_point[2]) + abs( img_points[,2] - start_point[1]))
idx_end = which.min( abs( img_points[,1] - end_point[2]) + abs( img_points[,2] - end_point[1]))
# shortest path algorithm
news.path <- shortest_paths(g,from = idx_start,
to = idx_end,
output = "both") # both path nodes and edges
# Find those poitns in lat,lon
path_squirrel = news.path$vpath[[1]] %>% as.numeric
path_points = img_points[path_squirrel,1:2]
# Save squirrel path
write.csv(data.frame(lon = path_points[,1],
lat = path_points[,2],
n = path_squirrel),
file="Files/path_coordinates_solution.csv",row.names=F)
Visualize solution
The path and the roughness (land cover) map is displayed below. Due to its size, the land cover map needs to be aggregated by a factor of 3(i.e., reduce its size).
LS0tCnRpdGxlOiAiU3F1aXJyZWwiCm91dHB1dDogCiAgaHRtbF9ub3RlYm9vazoKICAgIHRvYzogeWVzCiAgICB0b2NfY29sbGFwc2U6IG5vCiAgICB0b2NfZmxvYXQ6IHllcwotLS0KCmBgYHtyLCBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFLCBpbmNsdWRlPUZBTFNFfQojIExvYWQgcGFja2FnZXMKbGlicmFyeShyYXN0ZXIpCmxpYnJhcnkobGVhZmxldCkKbGlicmFyeShwbG90bHkpCmxpYnJhcnkoaWdyYXBoKQpsaWJyYXJ5KE1hdHJpeCkKbGlicmFyeShodG1sd2lkZ2V0cykKCiMgTG9hZCBob21lbWFkZSBmdW5jdGlvbnMKc291cmNlKCdidWlsZF9tYXRyaXhfZ3JhcGguUicpCmBgYAoKCiMgRG93bmxvYWQgYW5kIGxvYWQgcmFzdGVyCgpUaGUgcmFzdGVyIGlzIGZyZWVseSBhdmFpbGFibGUgZnJvbSB0aGUgd2ViCgpgYGB7ciwgZWNobz1UUlVFfQojIERvd25sb2FkIGdsb2JDb3ZlciBkYXRhc2V0CiMgZG93bmxvYWQuZmlsZSgnaHR0cDovL2R1ZS5lc3Jpbi5lc2EuaW50L2ZpbGVzL0dsb2Jjb3ZlcjIwMDlfVjIuM19HbG9iYWxfLnppcCcsZGVzdGZpbGUgPSAiR2xvYmNvdmVyMjAwOV9WMi4zX0dsb2JhbF8uemlwIikKIyB1bnppcCgnR2xvYmNvdmVyMjAwOV9WMi4zX0dsb2JhbF8uemlwJyxleGRpciA9ICdHbG9iQ292ZXInKQojIExvYWQgcmFzdGVyCmdsb2IgPSByYXN0ZXIoIkdMT0JDT1ZFUl9MNF8yMDA5MDFfMjAwOTEyX1YyLjMudGlmIikKYGBgCgpXZSBhbHNvIG5lZWQgdG8gbWFwIHRoZSBHbG9iY292ZXIgbGFiZWxzIHRvIGEgY29udGlub3VzIG51bWJlciwgYXMgaW5kaWNhdGVkIGJ5IHRoZSBsZWdlbmQgZm91bmQgW2hlcmVdKGh0dHA6Ly9kdWUuZXNyaW4uZXNhLmludC9wYWdlX2dsb2Jjb3Zlci5waHApLiBXZSBzZXQgd2F0ZXIgYm9kaWVzIHRvIF9OQV8uIExhdGVyIG9uLCB3ZSBzZXQgdGhlIHJvdWdobmVzcyBvdCB3YXRlciBib2RpZXMgdG8gMTAwIHRvIGluZGljYXRlIHRoYXQgdGhlIHNxdWlycmVsIGNhbm5vdCBzd2ltIG92ZXIgdGhlbS4KYGBge3J9CiMgbWFwIGxhYmVscyB0byByb3VnaG5lc3MgdmFsdWVzCmdsb2JDb3ZlciA9IGMoMTEsMTQsMjAsMzAsNDAsNTAsNjAsNzAsOTAsMTAwLAogICAgICAgICAgICAgIDExMCwxMjAsMTMwLDE0MCwxNTAsMTYwLDE3MCwxODAsMTkwLDIwMCwyMTAsMjIwLDIzMCkKcm91Z2huZXNzID0gYygwLjEwLCAgMC4xMCwgIDAuMzAsICAwLjMwLCAgMS41MCwgIDEuNTAsICAxLjUwLCAgMS41MCwgIDEuNTAsICAxLjUwLAogICAgICAgICAgICAgIDEuNTAsICAwLjUwLCAgMC4xMCwgIDAuMDMsICAwLjA1LCAgMC41MCwgIDAuNjAsICAwLjIwLCAgMS4wMCwgIE5BLCAgTkEsICBOQSwgIE5BKQpgYGAKCgojIE1hcCBvZiBTcGFpbgoKV2UgY2hvcCBhIHNtYWxsIHNlY3Rpb24gb2YgdGhlIHdvcmxkIG1hcCBhcm91bmQgdGhlIEliZXJpYW4gcGVuaW5zdWxhLiBUaGUgY29kZSBpcyBtYWRlIHRvIHdvcmsgb25seSBmb3Igc3F1YXJlZCByYXN0ZXJzLgoKVGhlIHN0YXJ0IGFuZCBlbmQgcG9pbnRzIG9mIHRoZSBwYXRoIGFyZSBzZXQgdG8gYmUgdGhlIG5vcnRoZXJubW9zdCBwb2ludCAoRXN0YWNhIGRvIGJhcmVzKSBhbmQgdGhlIHNvdXJ0aGVybm1vc3Qgb25lIChUYXJpZmEpLgoKYGBge3IsIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9CiMgQ2hvcCBhIHNtYWxsIHNlY3Rpb24KbGF0ID0gNDAKbG9uID0gLTUuMQpuPTQuNSAjIHdpZHRoIG9mIHRoZSBib3gKY3JvcGJveDIgPC1jKGxvbi1uLGxvbituLGxhdC1uLGxhdCtuKSAjIGNyb3AgYSBzcXVhcmUgYm94CnNwYWluX2ltZyA9IGNyb3AoZ2xvYixjcm9wYm94MikKCiMgcmUtY2xhc3NpZnkgdGhlIHJhc3RlciB2YWx1ZXMgdG8gbnVtZXJpYwpzbWFsbF9pbWdfcGxvdCA9IHJlY2xhc3NpZnkoc3BhaW5faW1nLGNiaW5kKGdsb2JDb3Zlcixyb3VnaG5lc3MpKQojIExldCdzIHRyYW5mb3JtIE5BIHZhbHVlcyB0byAiLTEwMCIgcm91Z2huZXNzIHNvIHRoYXQgd2Ugc3F1aXJyZWwgY2Fubm90IHN3aW0uIFRoaXMgb25lIGlzIG9ubHkgdXNlZCBmb3IgY2FsY3VsYXRpb25zLgpzbWFsbF9pbWcgPSByZWNsYXNzaWZ5KHNtYWxsX2ltZ19wbG90LGMoTkEsLTEwMCwtMTAwKSkKCiMgU2F2ZSB0aGUgcmFzdGVycyBmb3IgbGF0ZXIgdXNlIGluIHRoZSBkYXNoYm9hcmQKcmFzdGVyOjp3cml0ZVJhc3RlcihzcGFpbl9pbWcsICJGaWxlcy9HbG9iQ292ZXJfU3BhaW4udGlmIixvdmVyd3JpdGU9VFJVRSkKCiMgUGxvdAojIHBsb3Qoc3BhaW5faW1nKSAjIE9yaWdpbmFsIGdsb2Jjb3ZlciBsYWJlbHMKcGxvdChzbWFsbF9pbWdfcGxvdCkgIyB0cmFuc2Zvcm1lZCBsYWJlbHMsIHdpdGggTkEKIyBwbG90KHNtYWxsX2ltZykgIyB3ZSB1c2UgdGhpcyBvbmUgZm9yIHRoZSBhbmFseXNpcyB3aXRoIE5BPS0xMDAKCiMgU3RhcnQgYW5kIGVuZCBwb2ludHMKc3RhcnRfcG9pbnQgPSBjKDQzLjc4MDgyNCwgLTcuNjgxNDc5KSAjIEVzdGFjYSBkbyBiYXJlcwplbmRfcG9pbnQgPSBjKDM2LjAwMzc5NywgLTUuNjA5MTI0KSMgVGFyaWZhCgojIFBsb3Qgc3RhcnQgYW5kIGVuZCBwb2ludHMKcG9pbnRzKHg9c3RhcnRfcG9pbnRbMl0seT1zdGFydF9wb2ludFsxXSxwY2g9MTkpCnBvaW50cyh4PWVuZF9wb2ludFsyXSx5PWVuZF9wb2ludFsxXSxwY2g9MTkpCmBgYAoKRGltZW5zaW9ucyBvZiB0aGUgcmFzdGVyOgpgYGB7ciwgZWNobz1UUlVFLCBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQojIHRyYW5zbGF0ZSByYXN0ZXIgdG8gbWF0cml4Cm1hdCA9IHJhc3Rlcjo6YXMubWF0cml4KHNtYWxsX2ltZykKCiMgY3JlYXRlIDAtMSBlZGdlIG1hdHJpeApOID0gZGltKG1hdClbMV0gKiBkaW0obWF0KVsyXSAjIE51bWJlciBvZiB2ZXJ0aWNlcwpOaT0gZGltKG1hdClbMV0gIyBudW1iZXIgb2Ygcm93cwpOaj0gZGltKG1hdClbMl0gIyBudW1iZXIgb2YgY29sdW1ucwoKTgpgYGAKCgpOZXh0IHdlIGNyZWF0ZSB0aGUgZ3JhcGggYXMgYSBtYXRyaXguIFRoZSBtYXRyaXggaXMgZXF1YWwgdG8gYSAwIGlmIHR3byBwaXhlbHMgYXJlIG5vdCBsaW5rZWQsIGFuZCBlcXVhbCB0byB0aGUgcm91Z2huZXNzIG9mIHRoZWluY29taW5nIHBpeGVsIGlmIHRoZXkgYXJlLiBUd28gcGl4ZWxzIGFyZSBsaW5rZWQgaWYgdGhleSBhcmUgYWRqYWNlbnQgdG8gZWFjaCBvdGhlci4gVGhpcyBodWdlIG1hdHJpeCBvZiBkaW1lbnNpb24gYHIgTmAgYnkgYHIgTmAgaXMgcmVhbGx5IHNwYXJzZSBhbmQgdW5sZXNzIG9wdGltaXplZCB0YWtlcyB0b28gbG9uZyB0byBiZSBjcmVhdGVkLiBJdCBpcyBidWlsZCBpbnNpZGUgdGhlIGZ1bmN0aW9uIF9idWlsZF9tYXRyaXhfZ3JhcGgoKV8gYW5kIGl0IHRvb2sgZmV3IHRyaWVzIHRvIG1ha2UgaXQgcnVuIGF0IHJlYXNvbmFibGUgc3BlZWRzLgoKVGhlIHZhbHVlcyBvZiB0aGUgcmFzdGVyIGFyZSBzbGlnaGx5IG1vZGlmaWVkIHRvIGJlIHVzZWQgaW4gYSBzdGFuZGFyZCBzaG9ydGVzdC1wYXRoIGFsZ29yaXRobTogMC4wMDAwMDAxIHdlaWdodCBvbiBhbiBlZGdlIG1lYW5zICJmb3Jlc3QiLCB3aGlsZSAxLjUgbWVhbnMgImJhcmUgbGFuZCIgYW5kIDEwMCBtZWFucyAid2F0ZXIgYm9kaWVzIi4KCmBgYHtyLCBlY2hvPVRSVUUsIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9CiMgQ2FsbCBvdXIgaG9tZW1hZGUgZnVuY3Rpb24KdmFsX3Jhc3RlciA9IDEuNS12YWx1ZXMoc21hbGxfaW1nKSswLjAwMDAwMDEKCnQgPSBTeXMudGltZSgpCm1hdF9wYXRoID0gYnVpbGRfbWF0cml4X2dyYXBoKE5pLE5qLHZhbF9yYXN0ZXIgPSB2YWxfcmFzdGVyKQpTeXMudGltZSgpIC0gdAoKbWF0X3BhdGhbMToxMCwxOjEwXQpgYGAKClRoZSBzaG9ydGVzdCBwYXRoIGlzIGNsYXVsY2F0ZWQgdXNpbmcgdGhlIFtpZ3JhcGhdKGh0dHA6Ly9pZ3JhcGgub3JnLykgbGlicmFyeS4gSXQgd29ya3Mgc3VycHJpc2luZ2x5IGZhc3QuCgpgYGB7ciwgZWNobz1UUlVFLCBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQojIEJ1aWxkIGlncmFwaApnIDwtIGdyYXBoLmFkamFjZW5jeShtYXRfcGF0aCwgbW9kZT0iZGlyZWN0ZWQiLHdlaWdodGVkID0gVCkKICAKIyMgQ2FsY3VsYXRlIHNob3J0ZXN0IHBhdGggYmV0d2VlbiB0d28gcG9pdG5zCgojIEZpbmQgaW5kZXggb2YgdGhlIHN0YXJ0IGFuZCBlbmQgcG9pbnQKaW1nX3BvaW50cyA9IHJhc3RlclRvUG9pbnRzKHNtYWxsX2ltZykKaWR4X3N0YXJ0ID0gd2hpY2gubWluKCBhYnMoIGltZ19wb2ludHNbLDFdIC0gc3RhcnRfcG9pbnRbMl0pICsgYWJzKCBpbWdfcG9pbnRzWywyXSAtIHN0YXJ0X3BvaW50WzFdKSkKaWR4X2VuZCA9IHdoaWNoLm1pbiggYWJzKCBpbWdfcG9pbnRzWywxXSAtIGVuZF9wb2ludFsyXSkgKyBhYnMoIGltZ19wb2ludHNbLDJdIC0gZW5kX3BvaW50WzFdKSkKICAgICAgICAgICAgICAgICAgICAgCiMgc2hvcnRlc3QgcGF0aCBhbGdvcml0aG0KbmV3cy5wYXRoIDwtIHNob3J0ZXN0X3BhdGhzKGcsZnJvbSA9IGlkeF9zdGFydCwgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICB0byAgPSBpZHhfZW5kLAogICAgICAgICAgICAgICAgICAgICAgICAgICAgb3V0cHV0ID0gImJvdGgiKSAjIGJvdGggcGF0aCBub2RlcyBhbmQgZWRnZXMKCiMgRmluZCB0aG9zZSBwb2l0bnMgaW4gbGF0LGxvbgpwYXRoX3NxdWlycmVsID0gbmV3cy5wYXRoJHZwYXRoW1sxXV0gJT4lIGFzLm51bWVyaWMKcGF0aF9wb2ludHMgPSBpbWdfcG9pbnRzW3BhdGhfc3F1aXJyZWwsMToyXQoKIyBTYXZlIHNxdWlycmVsIHBhdGgKd3JpdGUuY3N2KGRhdGEuZnJhbWUobG9uID0gcGF0aF9wb2ludHNbLDFdLAogICAgICAgICAgIGxhdCA9IHBhdGhfcG9pbnRzWywyXSwKICAgICAgICAgICBuID0gcGF0aF9zcXVpcnJlbCksCiAgICAgICAgICBmaWxlPSJGaWxlcy9wYXRoX2Nvb3JkaW5hdGVzX3NvbHV0aW9uLmNzdiIscm93Lm5hbWVzPUYpCgpgYGAKCiMjIyBWaXN1YWxpemUgc29sdXRpb24KClRoZSBwYXRoIGFuZCB0aGUgcm91Z2huZXNzIChsYW5kIGNvdmVyKSBtYXAgaXMgZGlzcGxheWVkIGJlbG93LiBEdWUgdG8gaXRzIHNpemUsIHRoZSBsYW5kIGNvdmVyIG1hcCBuZWVkcyB0byBiZSBhZ2dyZWdhdGVkICBieSBhIGZhY3RvciBvZiAzKGkuZS4sIHJlZHVjZSBpdHMgc2l6ZSkuCgoKYGBge3IsIGVjaG89RkFMU0UsIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9CiMgVGhlIHJhc3RlciBpcyB0b28gYmlnIHRvIGJlIGRpc3BsYXllZCBzbyBsZXQncyBzaHJpbmsgaXQKYWdnX3NtYWxsX2ltZ19wbG90ID0gcmFzdGVyOjphZ2dyZWdhdGUoc21hbGxfaW1nX3Bsb3QsZmFjdD0zKQoKCiMgTWFrZSBhIGxlYWZsZXQgdmlzdWFsaXphdGlvbgogcGFsMiA9IGNvbG9yTnVtZXJpYygiUmRZbEduIiwgZG9tYWluID0gTlVMTCkKCmxsX21hcCA9ICBsZWFmbGV0KCkgJT4lCiAgIyBCYXNlIG1hcHMKICBhZGRQcm92aWRlclRpbGVzKCdFc3JpLldvcmxkR3JheUNhbnZhcycsZ3JvdXA9IkVzcmkgR3JleSIpICU+JQogIGFkZFByb3ZpZGVyVGlsZXMoJ0VzcmkuV29ybGRUb3BvTWFwJyxncm91cD0iRXNyaSBUb3BvIikgJT4lCiAgYWRkUHJvdmlkZXJUaWxlcygiRXNyaS5Xb3JsZEltYWdlcnkiLCBncm91cCA9ICJFc3JpIEltYWdlIikgJT4lCiAgIyAjIFJvdWdobmVzcyBpbmZvCiAgYWRkUmFzdGVySW1hZ2UoYWdnX3NtYWxsX2ltZ19wbG90LCBvcGFjaXR5ID0gMC41LGNvbG9ycz1wYWwyLCBncm91cD0iUm91Z2huZXNzIG1hcCIpICU+JQogIGFkZExlZ2VuZChwb3NpdGlvbj0iYm90dG9tbGVmdCIsIHBhbCA9IHBhbDIsIHZhbHVlcyA9IHZhbHVlcyhhZ2dfc21hbGxfaW1nX3Bsb3QpLAogIHRpdGxlID0gIlJvdWdobmVzcyIsCiAgb3BhY2l0eSA9IDEpICU+JQogICMgcGF0aCBpbmZvCiAgYWRkUG9seWxpbmVzKGxuZz1wYXRoX3BvaW50c1ssMV0sbGF0PXBhdGhfcG9pbnRzWywyXSxncm91cD0iUGF0aCIpICU+JSAKICAjIENvbnRyb2wgZ3JvdXBzCiAgYWRkTGF5ZXJzQ29udHJvbCgKICAgIGJhc2VHcm91cHMgPSBjKCJFc3JpIEdyZXkiLCJFc3JpIEltYWdlIiwiRXNyaSBUb3BvIiksCiAgICBvdmVybGF5R3JvdXBzID0gYygiUm91Z2huZXNzIG1hcCIsICJQYXRoIiksCiAgICBvcHRpb25zID0gbGF5ZXJzQ29udHJvbE9wdGlvbnMoY29sbGFwc2VkID0gRikKICApCmxsX21hcAoKIyBzYXZlV2lkZ2V0KGxsX21hcCwnZXhhbXBsZS5odG1sJykKYGBg